home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / miscpas.zip / CALC.PAS < prev    next >
Pascal/Delphi Source File  |  1980-01-01  |  4KB  |  201 lines
  1. PROGRAM CALCULATOR; (*$R-,K-*)
  2.  
  3. (* This program acts like a calculator - You type an expression    *)
  4. (* and the program calculates its value. Each time the calcula-    *)
  5. (* tor is ready to accept an input line, it prints an asterisk.    *)
  6. (* You must then type the expression and end it by pressing the    *)
  7. (* RETURN key, and shortly after, the result is displayed. If    *)
  8. (* the calculator finds an error, it displays a pointer, which    *)
  9. (* points at the error. There are five different operators (^,    *)
  10. (* *, /, +, and -), and seven standard functions (ABS, SQRT,    *)
  11. (* SIN, COS, ARCTAN, LN, and EXP). Parentheses within expres-    *)
  12. (* sions are allowed. A special variable, called X, always    *)
  13. (* holds the value of the last computation. To end the program,    *)
  14. (* type QUIT when the calculator prompts for an input line.    *)
  15.  
  16. CONST
  17.   STRLEN = 48;
  18. TYPE
  19.   STR = STRING[STRLEN];
  20. VAR
  21.   E: INTEGER;
  22.   R: REAL;
  23.   S: STR;
  24.  
  25. PROCEDURE EVALUATE(VAR EXPR: STR; VAR VALUE: REAL; VAR ERRPOS: INTEGER);
  26. CONST
  27.   ERRCH = '?';
  28.   EOFLINE = @13;
  29. VAR
  30.   POS: INTEGER;
  31.   CH: CHAR;
  32.  
  33. PROCEDURE NEXTCHAR;
  34. BEGIN
  35.   REPEAT
  36.     POS:=POS+1;
  37.     IF POS<=LEN(EXPR) THEN
  38.     CH:=EXPR[POS] ELSE
  39.     CH:=EOFLINE;
  40.   UNTIL CH<>' ';
  41. END;
  42.  
  43. FUNCTION EXPRESSION: REAL;
  44. VAR
  45.   E: REAL;
  46.   OPR: CHAR;
  47.  
  48. FUNCTION SIMEXPR: REAL;
  49. VAR
  50.   S: REAL;
  51.   OPR: CHAR;
  52.  
  53. FUNCTION TERM: REAL;
  54. VAR
  55.   T: REAL;
  56.  
  57. FUNCTION SIGNEDFACTOR: REAL;
  58.  
  59. FUNCTION FACTOR: REAL;
  60. TYPE
  61.   STDF = (FABS,FSQRT,FSIN,FCOS,FARCTAN,FLN,FEXP);
  62.   STDFLIST = ARRAY[STDF] OF STRING[6];
  63. CONST
  64.   STDFUN: STDFLIST = ('ABS','SQRT','SIN','COS','ARCTAN','LN','EXP');
  65. VAR
  66.   E,EE,L: INTEGER;
  67.   DECPOINT,NEGEXP,FOUND: BOOLEAN;
  68.   F: REAL;
  69.   SF: STDF;
  70. BEGIN
  71.   IF CH IN ['0'..'9'] THEN
  72.   BEGIN
  73.     F:=0.0; E:=0; DECPOINT:=FALSE;
  74.     REPEAT
  75.       F:=F*10.0+(ORD(CH)-48);
  76.       IF DECPOINT THEN E:=E-1;
  77.       NEXTCHAR;
  78.       IF (CH='.') AND NOT DECPOINT THEN
  79.       BEGIN
  80.     DECPOINT:=TRUE; NEXTCHAR;
  81.       END;
  82.     UNTIL NOT(CH IN ['0'..'9']);
  83.     IF CH='E' THEN
  84.     BEGIN
  85.       EE:=0; NEXTCHAR;
  86.       IF CH IN ['+','-'] THEN
  87.       BEGIN
  88.     NEGEXP:=CH='-'; NEXTCHAR;
  89.       END ELSE
  90.       NEGEXP:=FALSE;
  91.       WHILE CH IN ['0'..'9'] DO
  92.       BEGIN
  93.         EE:=EE*10+ORD(CH)-48;
  94.     NEXTCHAR;
  95.       END;
  96.       IF NEGEXP THEN E:=E-EE ELSE E:=E+EE;
  97.     END;
  98.     F:=F*PWRTEN(E);
  99.   END ELSE
  100.   IF CH='(' THEN
  101.   BEGIN
  102.     NEXTCHAR;
  103.     F:=EXPRESSION;
  104.     IF CH=')' THEN NEXTCHAR ELSE CH:=ERRCH;
  105.   END ELSE
  106.   IF CH='X' THEN
  107.   BEGIN
  108.     NEXTCHAR; F:=VALUE;
  109.   END ELSE
  110.   BEGIN
  111.     FOUND:=FALSE;
  112.     FOR SF:=FABS TO FEXP DO
  113.     IF NOT FOUND THEN
  114.     BEGIN
  115.       L:=LEN(STDFUN[SF]);
  116.       IF COPY(EXPR,POS,L)=STDFUN[SF] THEN
  117.       BEGIN
  118.     POS:=POS+L-1; NEXTCHAR;
  119.     F:=FACTOR;
  120.     CASE SF OF
  121.       FABS: F:=ABS(F);
  122.       FSQRT: F:=SQRT(F);
  123.       FSIN: F:=SIN(F);
  124.       FCOS: F:=COS(F);
  125.       FARCTAN: F:=ARCTAN(F);
  126.       FLN: F:=LN(F);
  127.       FEXP: F:=EXP(F);
  128.     END;
  129.     FOUND:=TRUE;
  130.       END;
  131.     END;
  132.     IF NOT FOUND THEN CH:=ERRCH;
  133.   END;
  134.   FACTOR:=F;
  135. END (*FACTOR*);
  136.  
  137. BEGIN (*SIGNEDFACTOR*)
  138.   IF CH='-' THEN
  139.   BEGIN
  140.     NEXTCHAR; SIGNEDFACTOR:=-FACTOR;
  141.   END ELSE
  142.   SIGNEDFACTOR:=FACTOR;
  143. END (*SIGNEDFACTOR*);
  144.  
  145. BEGIN (*TERM*)
  146.   T:=SIGNEDFACTOR;
  147.   WHILE CH='^' DO
  148.   BEGIN
  149.     NEXTCHAR; T:=EXP(LN(T)*SIGNEDFACTOR);
  150.   END;
  151.   TERM:=T;
  152. END (*TERM*);
  153.  
  154. BEGIN (*SIMEXPR*)
  155.   S:=TERM;
  156.   WHILE CH IN ['*','/'] DO
  157.   BEGIN
  158.     OPR:=CH; NEXTCHAR;
  159.     CASE OPR OF
  160.       '*': S:=S*TERM;
  161.       '/': S:=S/TERM;
  162.     END;
  163.   END;
  164.   SIMEXPR:=S;
  165. END (*SIMEXPR*);
  166.  
  167. BEGIN (*EXPRESSION*)
  168.   E:=SIMEXPR;
  169.   WHILE CH IN ['+','-'] DO
  170.   BEGIN
  171.     OPR:=CH; NEXTCHAR;
  172.     CASE OPR OF
  173.       '+': E:=E+SIMEXPR;
  174.       '-': E:=E-SIMEXPR;
  175.     END;
  176.   END;
  177.   EXPRESSION:=E;
  178. END (*EXPRESSION*);
  179.  
  180. BEGIN (*EVALUATE*)
  181.   POS:=0; NEXTCHAR;
  182.   VALUE:=EXPRESSION;
  183.   IF CH=EOFLINE THEN ERRPOS:=0 ELSE ERRPOS:=POS;
  184. END (*EVALUATE*);
  185.  
  186. BEGIN (*CALCULATOR*)
  187.   REPEAT
  188.     WRITE('* '); BUFLEN:=STRLEN; READ(S);
  189.     IF (S<>'') AND (S<>'QUIT') THEN
  190.     BEGIN
  191.       EVALUATE(S,R,E);
  192.       IF E=0 THEN WRITE(' =',R) ELSE
  193.       BEGIN
  194.     WRITELN;
  195.     WRITE('^ ERROR':E+8);
  196.       END;
  197.     END;
  198.     WRITELN;
  199.   UNTIL S='QUIT';
  200. END (*CALCULATOR*).
  201.